isnet Internet/Isnet Internet CD.iso/prog/hiz/09/09.exe/adynware.exe/perl/lib/bigfloat.pl

Perl Script | 1999-12-28 | 4.9 KB | 189 lines

package bigfloat;
require "bigint.pl";

$div_scale = 40;


$rnd_mode = 'even';


sub main'fnorm { #(string) return fnum_str
    local($_) = @_;
    s/\s+//g;                               # strip white space
    if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/
      && ($2 ne '' || defined($4))) {
    my $x = defined($4) ? $4 : '';
    &norm(($1 ? "$1$2$x" : "+$2$x"), (($x ne '') ? $6-length($x) : $6));
    } else {
    'NaN';
    }
}

sub norm { #(mantissa, exponent) return fnum_str
    local($_, $exp) = @_;
    if ($_ eq 'NaN') {
    'NaN';
    } else {
    s/^([+-])0+/$1/;                        # strip leading zeros
    if (length($_) == 1) {
        '+0E+0';
    } else {
        $exp += length($1) if (s/(0+)$//);  # strip trailing zeros
        sprintf("%sE%+ld", $_, $exp);
    }
    }
}

sub main'fneg { #(fnum_str) return fnum_str
    local($_) = &'fnorm($_[$[]);
    vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0E+0'; # flip sign
    s/^H/N/;
    $_;
}

sub main'fabs { #(fnum_str) return fnum_str
    local($_) = &'fnorm($_[$[]);
    s/^-/+/;                               # mash sign
    $_;
}

sub main'fmul { #(fnum_str, fnum_str) return fnum_str
    local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
    if ($x eq 'NaN' || $y eq 'NaN') {
    'NaN';
    } else {
    local($xm,$xe) = split('E',$x);
    local($ym,$ye) = split('E',$y);
    &norm(&'bmul($xm,$ym),$xe+$ye);
    }
}

sub main'fadd { #(fnum_str, fnum_str) return fnum_str
    local($x,$y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
    if ($x eq 'NaN' || $y eq 'NaN') {
    'NaN';
    } else {
    local($xm,$xe) = split('E',$x);
    local($ym,$ye) = split('E',$y);
    ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
    &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
    }
}

sub main'fsub { #(fnum_str, fnum_str) return fnum_str
    &'fadd($_[$[],&'fneg($_[$[+1]));
}

sub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
{
    local($x,$y,$scale) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]),$_[$[+2]);
    if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
    'NaN';
    } else {
    local($xm,$xe) = split('E',$x);
    local($ym,$ye) = split('E',$y);
    $scale = $div_scale if (!$scale);
    $scale = length($xm)-1 if (length($xm)-1 > $scale);
    $scale = length($ym)-1 if (length($ym)-1 > $scale);
    $scale = $scale + length($ym) - length($xm);
    &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym),
        $xe-$ye-$scale);
    }
}

sub round { #(int_str, int_str, int_str) return int_str
    local($q,$r,$base) = @_;
    if ($q eq 'NaN' || $r eq 'NaN') {
    'NaN';
    } elsif ($rnd_mode eq 'trunc') {
    $q;                         # just truncate
    } else {
    local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
    if ( $cmp < 0 ||
         ($cmp == 0 &&
          ( $rnd_mode eq 'zero'                             ||
           ($rnd_mode eq '-inf' && (substr($q,$[,1) eq '+')) ||
           ($rnd_mode eq '+inf' && (substr($q,$[,1) eq '-')) ||
           ($rnd_mode eq 'even' && $q =~ /[24680]$/)        ||
           ($rnd_mode eq 'odd'  && $q =~ /[13579]$/)        )) ) {
        $q;                     # round down
    } else {
        &'badd($q, ((substr($q,$[,1) eq '-') ? '-1' : '+1'));
    }
    }
}

sub main'fround { #(fnum_str, scale) return fnum_str
    local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
    if ($x eq 'NaN' || $scale <= 0) {
    $x;
    } else {
    local($xm,$xe) = split('E',$x);
    if (length($xm)-1 <= $scale) {
        $x;
    } else {
        &norm(&round(substr($xm,$[,$scale+1),
             "+0".substr($xm,$[+$scale+1,1),"+10"),
          $xe+length($xm)-$scale-1);
    }
    }
}

sub main'ffround { #(fnum_str, scale) return fnum_str
    local($x,$scale) = (&'fnorm($_[$[]),$_[$[+1]);
    if ($x eq 'NaN') {
    'NaN';
    } else {
    local($xm,$xe) = split('E',$x);
    if ($xe >= $scale) {
        $x;
    } else {
        $xe = length($xm)+$xe-$scale;
        if ($xe < 1) {
        '+0E+0';
        } elsif ($xe == 1) {
        &norm(&round('+0',"+0".substr($xm,$[+1,1),"+10"), $scale);
        } else {
        &norm(&round(substr($xm,$[,$xe),
              "+0".substr($xm,$[+$xe,1),"+10"), $scale);
        }
    }
    }
}

sub main'fcmp #(fnum_str, fnum_str) return cond_code
{
    local($x, $y) = (&'fnorm($_[$[]),&'fnorm($_[$[+1]));
    if ($x eq "NaN" || $y eq "NaN") {
    undef;
    } else {
    ord($y) <=> ord($x)
    ||
    (  local($xm,$xe,$ym,$ye) = split('E', $x."E$y"),
         (($xe <=> $ye) * (substr($x,$[,1).'1')
             || &bigint'cmp($xm,$ym))
    );
    }
}

sub main'fsqrt { #(fnum_str[, scale]) return fnum_str
    local($x, $scale) = (&'fnorm($_[$[]), $_[$[+1]);
    if ($x eq 'NaN' || $x =~ /^-/) {
    'NaN';
    } elsif ($x eq '+0E+0') {
    '+0E+0';
    } else {
    local($xm, $xe) = split('E',$x);
    $scale = $div_scale if (!$scale);
    $scale = length($xm)-1 if ($scale < length($xm)-1);
    local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
    while ($gs < 2*$scale) {
        $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
        $gs *= 2;
    }
    &'fround($guess, $scale);
    }
}

1;